home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / win / tclWinReg.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  29.9 KB  |  1,213 lines  |  [TEXT/CWIE]
  1. /* 
  2.  * tclWinReg.c --
  3.  *
  4.  *    This file contains the implementation of the "registry" Tcl
  5.  *    built-in command.  This command is built as a dynamically
  6.  *    loadable extension in a separate DLL.
  7.  *
  8.  * Copyright (c) 1997 by Sun Microsystems, Inc.
  9.  *
  10.  * See the file "license.terms" for information on usage and redistribution
  11.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  *
  13.  * SCCS: @(#) tclWinReg.c 1.8 97/08/01 11:17:49
  14.  */
  15.  
  16. #include <tcl.h>
  17. #include <stdlib.h>
  18.  
  19. #define WIN32_LEAN_AND_MEAN
  20. #include <windows.h>
  21. #undef WIN32_LEAN_AND_MEAN
  22.  
  23. /*
  24.  * VC++ has an alternate entry point called DllMain, so we need to rename
  25.  * our entry point.
  26.  */
  27.  
  28. #ifndef STATIC_BUILD
  29. #if defined(_MSC_VER)
  30. #   define EXPORT(a,b) __declspec(dllexport) a b
  31. #   define DllEntryPoint DllMain
  32. #else
  33. #   if defined(__BORLANDC__)
  34. #    define EXPORT(a,b) a _export b
  35. #   else
  36. #    define EXPORT(a,b) a b
  37. #   endif
  38. #endif
  39. #endif
  40.  
  41. /*
  42.  * The following macros convert between different endian ints.
  43.  */
  44.  
  45. #define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
  46. #define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
  47.  
  48. /*
  49.  * The following flag is used in OpenKeys to indicate that the specified
  50.  * key should be created if it doesn't currently exist.
  51.  */
  52.  
  53. #define REG_CREATE 1
  54.  
  55. /*
  56.  * The following tables contain the mapping from registry root names
  57.  * to the system predefined keys.
  58.  */
  59.  
  60. static char *rootKeyNames[] = {
  61.     "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
  62.     "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", NULL
  63. };
  64.  
  65. static HKEY rootKeys[] = {
  66.     HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
  67.     HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
  68. };
  69.  
  70. /*
  71.  * The following table maps from registry types to strings.  Note that
  72.  * the indices for this array are the same as the constants for the
  73.  * known registry types so we don't need a separate table to hold the
  74.  * mapping.
  75.  */
  76.  
  77. static char *typeNames[] = {
  78.     "none", "sz", "expand_sz", "binary", "dword", 
  79.     "dword_big_endian", "link", "multi_sz", "resource_list", NULL
  80. };
  81.  
  82. static DWORD lastType = REG_RESOURCE_REQUIREMENTS_LIST;
  83.  
  84.  
  85. /*
  86.  * Declarations for functions defined in this file.
  87.  */
  88.  
  89. static void        AppendSystemError(Tcl_Interp *interp, DWORD error);
  90. static DWORD        ConvertDWORD(DWORD type, DWORD value);
  91. static int        DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
  92. static int        DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
  93.                 Tcl_Obj *valueNameObj);
  94. static int        GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
  95.                 Tcl_Obj *patternObj);
  96. static int        GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
  97.                 Tcl_Obj *valueNameObj);
  98. static int        GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
  99.                 Tcl_Obj *valueNameObj);
  100. static int        GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
  101.                 Tcl_Obj *patternObj);
  102. static int        OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
  103.                 REGSAM mode, int flags, HKEY *keyPtr);
  104. static DWORD        OpenSubKey(char *hostName, HKEY rootKey,
  105.                 char *keyName, REGSAM mode, int flags,
  106.                 HKEY *keyPtr);
  107. static int        ParseKeyName(Tcl_Interp *interp, char *name,
  108.                 char **hostNamePtr, HKEY *rootKeyPtr,
  109.                 char **keyNamePtr);
  110. static DWORD        RecursiveDeleteKey(HKEY hStartKey, LPTSTR pKeyName);
  111. static int        RegistryObjCmd(ClientData clientData,
  112.                 Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]);
  113. static int        SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
  114.                 Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
  115.                 Tcl_Obj *typeObj);
  116.  
  117. EXTERN EXPORT(int,Registry_Init)(Tcl_Interp *interp);
  118.  
  119. /*
  120.  *----------------------------------------------------------------------
  121.  *
  122.  * DllEntryPoint --
  123.  *
  124.  *    This wrapper function is used by Windows to invoke the
  125.  *    initialization code for the DLL.  If we are compiling
  126.  *    with Visual C++, this routine will be renamed to DllMain.
  127.  *    routine.
  128.  *
  129.  * Results:
  130.  *    Returns TRUE;
  131.  *
  132.  * Side effects:
  133.  *    None.
  134.  *
  135.  *----------------------------------------------------------------------
  136.  */
  137.  
  138. #ifdef __WIN32__
  139. #ifndef STATIC_BUILD
  140. BOOL APIENTRY
  141. DllEntryPoint(
  142.     HINSTANCE hInst,        /* Library instance handle. */
  143.     DWORD reason,        /* Reason this function is being called. */
  144.     LPVOID reserved)        /* Not used. */
  145. {
  146.     return TRUE;
  147. }
  148. #endif
  149. #endif
  150.  
  151. /*
  152.  *----------------------------------------------------------------------
  153.  *
  154.  * Registry_Init --
  155.  *
  156.  *    This procedure initializes the registry command.
  157.  *
  158.  * Results:
  159.  *    A standard Tcl result.
  160.  *
  161.  * Side effects:
  162.  *    None.
  163.  *
  164.  *----------------------------------------------------------------------
  165.  */
  166.  
  167. EXPORT(int,Registry_Init)(
  168.     Tcl_Interp *interp)
  169. {
  170.     Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
  171.     return Tcl_PkgProvide(interp, "registry", "1.0");
  172. }
  173.  
  174. /*
  175.  *----------------------------------------------------------------------
  176.  *
  177.  * RegistryObjCmd --
  178.  *
  179.  *    This function implements the Tcl "registry" command.
  180.  *
  181.  * Results:
  182.  *    A standard Tcl result.
  183.  *
  184.  * Side effects:
  185.  *    None.
  186.  *
  187.  *----------------------------------------------------------------------
  188.  */
  189.  
  190. static int
  191. RegistryObjCmd(
  192.     ClientData clientData,    /* Not used. */
  193.     Tcl_Interp *interp,        /* Current interpreter. */
  194.     int objc,            /* Number of arguments. */
  195.     Tcl_Obj * CONST objv[])    /* Argument values. */
  196. {
  197.     int index;
  198.     char *errString;
  199.  
  200.     static char *subcommands[] = { "delete", "get", "keys", "set", "type",
  201.                    "values", (char *) NULL };
  202.     enum SubCmdIdx { DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx };
  203.  
  204.     if (objc < 2) {
  205.     Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?");
  206.     return TCL_ERROR;
  207.     }
  208.  
  209.     if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)
  210.         != TCL_OK) {
  211.     return TCL_ERROR;
  212.     }
  213.  
  214.     switch (index) {
  215.     case DeleteIdx:            /* delete */
  216.         if (objc == 3) {
  217.         return DeleteKey(interp, objv[2]);
  218.         } else if (objc == 4) {
  219.         return DeleteValue(interp, objv[2], objv[3]);
  220.         }
  221.         errString = "keyName ?valueName?";
  222.         break;
  223.     case GetIdx:            /* get */
  224.         if (objc == 4) {
  225.         return GetValue(interp, objv[2], objv[3]);
  226.         }
  227.         errString = "keyName valueName";
  228.         break;
  229.     case KeysIdx:            /* keys */
  230.         if (objc == 3) {
  231.         return GetKeyNames(interp, objv[2], NULL);
  232.         } else if (objc == 4) {
  233.         return GetKeyNames(interp, objv[2], objv[3]);
  234.         }
  235.         errString = "keyName ?pattern?";
  236.         break;
  237.     case SetIdx:            /* set */
  238.         if (objc == 3) {
  239.         HKEY key;
  240.  
  241.         /*
  242.          * Create the key and then close it immediately.
  243.          */
  244.  
  245.         if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key)
  246.             != TCL_OK) {
  247.             return TCL_ERROR;
  248.         }
  249.         RegCloseKey(key);
  250.         return TCL_OK;
  251.         } else if (objc == 5 || objc == 6) {
  252.         Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
  253.         return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
  254.         }
  255.         errString = "keyName ?valueName data ?type??";
  256.         break;
  257.     case TypeIdx:            /* type */
  258.         if (objc == 4) {
  259.         return GetType(interp, objv[2], objv[3]);
  260.         }
  261.         errString = "keyName valueName";
  262.         break;
  263.     case ValuesIdx:            /* values */
  264.         if (objc == 3) {
  265.          return GetValueNames(interp, objv[2], NULL);
  266.         } else if (objc == 4) {
  267.          return GetValueNames(interp, objv[2], objv[3]);
  268.         }
  269.         errString = "keyName ?pattern?";
  270.         break;
  271.     }
  272.     Tcl_WrongNumArgs(interp, 2, objv, errString);
  273.     return TCL_ERROR;
  274. }
  275.  
  276. /*
  277.  *----------------------------------------------------------------------
  278.  *
  279.  * DeleteKey --
  280.  *
  281.  *    This function deletes a registry key.
  282.  *
  283.  * Results:
  284.  *    A standard Tcl result.
  285.  *
  286.  * Side effects:
  287.  *    None.
  288.  *
  289.  *----------------------------------------------------------------------
  290.  */
  291.  
  292. static int
  293. DeleteKey(
  294.     Tcl_Interp *interp,        /* Current interpreter. */
  295.     Tcl_Obj *keyNameObj)    /* Name of key to delete. */
  296. {
  297.     char *tail, *buffer, *hostName, *keyName;
  298.     HKEY rootKey, subkey;
  299.     DWORD result;
  300.     int length;
  301.     Tcl_Obj *resultPtr;
  302.  
  303.     /*
  304.      * Find the parent of the key being deleted and open it.
  305.      */
  306.  
  307.     keyName = Tcl_GetStringFromObj(keyNameObj, &length);
  308.     buffer = ckalloc(length + 1);
  309.     strcpy(buffer, keyName);
  310.  
  311.     if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName)
  312.         != TCL_OK) {
  313.     ckfree(buffer);
  314.     return TCL_ERROR;
  315.     }
  316.  
  317.     resultPtr = Tcl_GetObjResult(interp);
  318.     if (*keyName == '\0') {
  319.     Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1);
  320.     ckfree(buffer);
  321.     return TCL_ERROR;
  322.     }
  323.  
  324.     tail = strrchr(keyName, '\\');
  325.     if (tail) {
  326.     *tail++ = '\0';
  327.     } else {
  328.     tail = keyName;
  329.     keyName = NULL;
  330.     }
  331.  
  332.     result = OpenSubKey(hostName, rootKey, keyName,
  333.         KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);
  334.     if (result != ERROR_SUCCESS) {
  335.     ckfree(buffer);
  336.     if (result == ERROR_FILE_NOT_FOUND) {
  337.         return TCL_OK;
  338.     } else {
  339.         Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
  340.         AppendSystemError(interp, result);
  341.         return TCL_ERROR;
  342.     }
  343.     }
  344.  
  345.     /*
  346.      * Now we recursively delete the key and everything below it.
  347.      */
  348.  
  349.     result = RecursiveDeleteKey(subkey, tail);
  350.  
  351.     if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
  352.     Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
  353.     AppendSystemError(interp, result);
  354.     result = TCL_ERROR;
  355.     } else {
  356.     result = TCL_OK;
  357.     }
  358.  
  359.     RegCloseKey(subkey);
  360.     ckfree(buffer);
  361.     return result;
  362. }
  363.  
  364. /*
  365.  *----------------------------------------------------------------------
  366.  *
  367.  * DeleteValue --
  368.  *
  369.  *    This function deletes a value from a registry key.
  370.  *
  371.  * Results:
  372.  *    A standard Tcl result.
  373.  *
  374.  * Side effects:
  375.  *    None.
  376.  *
  377.  *----------------------------------------------------------------------
  378.  */
  379.  
  380. static int
  381. DeleteValue(
  382.     Tcl_Interp *interp,        /* Current interpreter. */
  383.     Tcl_Obj *keyNameObj,    /* Name of key. */
  384.     Tcl_Obj *valueNameObj)    /* Name of value to delete. */
  385. {
  386.     HKEY key;
  387.     char *valueName;
  388.     int length;
  389.     DWORD result;
  390.     Tcl_Obj *resultPtr;
  391.     
  392.     /*
  393.      * Attempt to open the key for deletion.
  394.      */
  395.  
  396.     if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)
  397.         != TCL_OK) {
  398.     return TCL_ERROR;
  399.     }
  400.  
  401.     resultPtr = Tcl_GetObjResult(interp);
  402.     valueName = Tcl_GetStringFromObj(valueNameObj, &length);
  403.     result = RegDeleteValue(key, valueName);
  404.     if (result != ERROR_SUCCESS) {
  405.     Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",
  406.         Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
  407.         Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
  408.     AppendSystemError(interp, result);
  409.     result = TCL_ERROR;
  410.     } else {
  411.     result = TCL_OK;
  412.     }
  413.     RegCloseKey(key);
  414.     return result;
  415. }
  416.  
  417. /*
  418.  *----------------------------------------------------------------------
  419.  *
  420.  * GetKeyNames --
  421.  *
  422.  *    This function enumerates the subkeys of a given key.  If the
  423.  *    optional pattern is supplied, then only keys that match the
  424.  *    pattern will be returned.
  425.  *
  426.  * Results:
  427.  *    Returns the list of subkeys in the result object of the
  428.  *    interpreter, or an error message on failure.
  429.  *
  430.  * Side effects:
  431.  *    None.
  432.  *
  433.  *----------------------------------------------------------------------
  434.  */
  435.  
  436. static int
  437. GetKeyNames(
  438.     Tcl_Interp *interp,        /* Current interpreter. */
  439.     Tcl_Obj *keyNameObj,    /* Key to enumerate. */
  440.     Tcl_Obj *patternObj)    /* Optional match pattern. */
  441. {
  442.     HKEY key;
  443.     DWORD index;
  444.     char buffer[MAX_PATH+1], *pattern;
  445.     Tcl_Obj *resultPtr;
  446.     int result = TCL_OK;
  447.  
  448.     /*
  449.      * Attempt to open the key for enumeration.
  450.      */
  451.  
  452.     if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key)
  453.         != TCL_OK) {
  454.     return TCL_ERROR;
  455.     }
  456.  
  457.     if (patternObj) {
  458.     pattern = Tcl_GetStringFromObj(patternObj, NULL);
  459.     } else {
  460.     pattern = NULL;
  461.     }
  462.  
  463.     /*
  464.      * Enumerate over the subkeys until we get an error, indicating the
  465.      * end of the list.
  466.      */
  467.  
  468.     resultPtr = Tcl_GetObjResult(interp);
  469.     for (index = 0; RegEnumKey(key, index, buffer, MAX_PATH+1)
  470.          == ERROR_SUCCESS; index++) {
  471.     if (pattern && !Tcl_StringMatch(buffer, pattern)) {
  472.         continue;
  473.     }
  474.     result = Tcl_ListObjAppendElement(interp, resultPtr,
  475.         Tcl_NewStringObj(buffer, -1));
  476.     if (result != TCL_OK) {
  477.         break;
  478.     }
  479.     }
  480.  
  481.     RegCloseKey(key);
  482.     return result;
  483. }
  484.  
  485. /*
  486.  *----------------------------------------------------------------------
  487.  *
  488.  * GetType --
  489.  *
  490.  *    This function gets the type of a given registry value and
  491.  *    places it in the interpreter result.
  492.  *
  493.  * Results:
  494.  *    Returns a normal Tcl result.
  495.  *
  496.  * Side effects:
  497.  *    None.
  498.  *
  499.  *----------------------------------------------------------------------
  500.  */
  501.  
  502. static int
  503. GetType(
  504.     Tcl_Interp *interp,        /* Current interpreter. */
  505.     Tcl_Obj *keyNameObj,    /* Name of key. */
  506.     Tcl_Obj *valueNameObj)    /* Name of value to get. */
  507. {
  508.     HKEY key;
  509.     Tcl_Obj *resultPtr;
  510.     DWORD result;
  511.     DWORD type;
  512.     
  513.     /*
  514.      * Attempt to open the key for reading.
  515.      */
  516.  
  517.     if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
  518.         != TCL_OK) {
  519.     return TCL_ERROR;
  520.     }
  521.  
  522.     /*
  523.      * Get the type of the value.
  524.      */
  525.  
  526.     resultPtr = Tcl_GetObjResult(interp);
  527.  
  528.     result = RegQueryValueEx(key, Tcl_GetStringFromObj(valueNameObj, NULL),
  529.         NULL, &type, NULL, NULL);
  530.     RegCloseKey(key);
  531.  
  532.     if (result != ERROR_SUCCESS) {
  533.     Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"",
  534.         Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
  535.         Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
  536.     AppendSystemError(interp, result);
  537.     return TCL_ERROR;
  538.     }
  539.  
  540.     /*
  541.      * Set the type into the result.  Watch out for unknown types.
  542.      * If we don't know about the type, just use the numeric value.
  543.      */
  544.  
  545.     if (type > lastType) {
  546.     Tcl_SetIntObj(resultPtr, type);
  547.     } else {
  548.     Tcl_SetStringObj(resultPtr, typeNames[type], -1);
  549.     }
  550.     return TCL_OK;
  551. }
  552.  
  553. /*
  554.  *----------------------------------------------------------------------
  555.  *
  556.  * GetValue --
  557.  *
  558.  *    This function gets the contents of a registry value and places
  559.  *    a list containing the data and the type in the interpreter
  560.  *    result.
  561.  *
  562.  * Results:
  563.  *    Returns a normal Tcl result.
  564.  *
  565.  * Side effects:
  566.  *    None.
  567.  *
  568.  *----------------------------------------------------------------------
  569.  */
  570.  
  571. static int
  572. GetValue(
  573.     Tcl_Interp *interp,        /* Current interpreter. */
  574.     Tcl_Obj *keyNameObj,    /* Name of key. */
  575.     Tcl_Obj *valueNameObj)    /* Name of value to get. */
  576. {
  577.     HKEY key;
  578.     char *valueName;
  579.     DWORD result, length, type;
  580.     Tcl_Obj *resultPtr;
  581.     Tcl_DString data;
  582.  
  583.     /*
  584.      * Attempt to open the key for reading.
  585.      */
  586.  
  587.     if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
  588.         != TCL_OK) {
  589.     return TCL_ERROR;
  590.     }
  591.  
  592.     /*
  593.      * Get the value once to determine the length then again to store
  594.      * the data in the buffer.
  595.      */
  596.  
  597.     Tcl_DStringInit(&data);
  598.     resultPtr = Tcl_GetObjResult(interp);
  599.  
  600.     valueName = Tcl_GetStringFromObj(valueNameObj, (int*) &length);
  601.     result = RegQueryValueEx(key, valueName, NULL, &type, NULL, &length);
  602.     if (result == ERROR_SUCCESS) {
  603.     Tcl_DStringSetLength(&data, length);
  604.     result = RegQueryValueEx(key, valueName, NULL, &type,
  605.         (LPBYTE) Tcl_DStringValue(&data), &length);
  606.     }
  607.     RegCloseKey(key);
  608.     if (result != ERROR_SUCCESS) {
  609.     Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",
  610.         Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
  611.         Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
  612.     AppendSystemError(interp, result);
  613.     Tcl_DStringFree(&data);
  614.     return TCL_ERROR;
  615.     }
  616.  
  617.     /*
  618.      * If the data is a 32-bit quantity, store it as an integer object.  If it
  619.      * is a multi-string, store it as a list of strings.  For null-terminated
  620.      * strings, append up the to first null.  Otherwise, store it as a binary
  621.      * string.
  622.      */
  623.  
  624.     if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
  625.     Tcl_SetIntObj(resultPtr, ConvertDWORD(type,
  626.         *((DWORD*) Tcl_DStringValue(&data))));
  627.     } else if (type == REG_MULTI_SZ) {
  628.     char *p = Tcl_DStringValue(&data);
  629.     char *lastChar = Tcl_DStringValue(&data) + Tcl_DStringLength(&data);
  630.  
  631.     /*
  632.      * Multistrings are stored as an array of null-terminated strings,
  633.      * terminated by two null characters.  Also do a bounds check in
  634.      * case we get bogus data.
  635.      */
  636.  
  637.     while (p < lastChar && *p != '\0') {
  638.         Tcl_ListObjAppendElement(interp, resultPtr,
  639.             Tcl_NewStringObj(p, -1));
  640.         while (*p++ != '\0') {}
  641.     }
  642.     } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
  643.     Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), -1);
  644.     } else {
  645.     Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), length);
  646.     }
  647.     Tcl_DStringFree(&data);
  648.     return result;
  649. }
  650.  
  651. /*
  652.  *----------------------------------------------------------------------
  653.  *
  654.  * GetValueNames --
  655.  *
  656.  *    This function enumerates the values of the a given key.  If
  657.  *    the optional pattern is supplied, then only value names that
  658.  *    match the pattern will be returned.
  659.  *
  660.  * Results:
  661.  *    Returns the list of value names in the result object of the
  662.  *    interpreter, or an error message on failure.
  663.  *
  664.  * Side effects:
  665.  *    None.
  666.  *
  667.  *----------------------------------------------------------------------
  668.  */
  669.  
  670. static int
  671. GetValueNames(
  672.     Tcl_Interp *interp,        /* Current interpreter. */
  673.     Tcl_Obj *keyNameObj,    /* Key to enumerate. */
  674.     Tcl_Obj *patternObj)    /* Optional match pattern. */
  675. {
  676.     HKEY key;
  677.     Tcl_Obj *resultPtr;
  678.     DWORD index, size, result;
  679.     Tcl_DString buffer;
  680.     char *pattern;
  681.  
  682.     /*
  683.      * Attempt to open the key for enumeration.
  684.      */
  685.  
  686.     if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
  687.         != TCL_OK) {
  688.     return TCL_ERROR;
  689.     }
  690.  
  691.     resultPtr = Tcl_GetObjResult(interp);
  692.  
  693.     /*
  694.      * Query the key to determine the appropriate buffer size to hold the
  695.      * largest value name plus the terminating null.
  696.      */
  697.  
  698.     result = RegQueryInfoKey(key, NULL, NULL, NULL, NULL, NULL, NULL, &index,
  699.     &size, NULL, NULL, NULL);
  700.     if (result != ERROR_SUCCESS) {
  701.     Tcl_AppendStringsToObj(resultPtr, "unable to query key \"",
  702.         Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
  703.     AppendSystemError(interp, result);
  704.     RegCloseKey(key);
  705.     result = TCL_ERROR;
  706.     goto done;
  707.     }
  708.     size++;
  709.  
  710.  
  711.     Tcl_DStringInit(&buffer);
  712.     Tcl_DStringSetLength(&buffer, size);
  713.     index = 0;
  714.     result = TCL_OK;
  715.  
  716.     if (patternObj) {
  717.     pattern = Tcl_GetStringFromObj(patternObj, NULL);
  718.     } else {
  719.     pattern = NULL;
  720.     }
  721.  
  722.     /*
  723.      * Enumerate the values under the given subkey until we get an error,
  724.      * indicating the end of the list.  Note that we need to reset size
  725.      * after each iteration because RegEnumValue smashes the old value.
  726.      */
  727.  
  728.     while (RegEnumValue(key, index, Tcl_DStringValue(&buffer), &size, NULL,
  729.         NULL, NULL, NULL) == ERROR_SUCCESS) {
  730.     if (!pattern || Tcl_StringMatch(Tcl_DStringValue(&buffer), pattern)) {
  731.         result = Tcl_ListObjAppendElement(interp, resultPtr,
  732.             Tcl_NewStringObj(Tcl_DStringValue(&buffer), size));
  733.         if (result != TCL_OK) {
  734.         break;
  735.         }
  736.     }
  737.     index++;
  738.     size = Tcl_DStringLength(&buffer);
  739.     }
  740.     Tcl_DStringFree(&buffer);
  741.  
  742.     done:
  743.     RegCloseKey(key);
  744.     return result;
  745. }
  746.  
  747. /*
  748.  *----------------------------------------------------------------------
  749.  *
  750.  * OpenKey --
  751.  *
  752.  *    This function opens the specified key.  This function is a
  753.  *    simple wrapper around ParseKeyName and OpenSubKey.
  754.  *
  755.  * Results:
  756.  *    Returns the opened key in the keyPtr argument and a Tcl
  757.  *    result code.
  758.  *
  759.  * Side effects:
  760.  *    None.
  761.  *
  762.  *----------------------------------------------------------------------
  763.  */
  764.  
  765. static int
  766. OpenKey(
  767.     Tcl_Interp *interp,        /* Current interpreter. */
  768.     Tcl_Obj *keyNameObj,    /* Key to open. */
  769.     REGSAM mode,        /* Access mode. */
  770.     int flags,            /* 0 or REG_CREATE. */
  771.     HKEY *keyPtr)        /* Returned HKEY. */
  772. {
  773.     char *keyName, *buffer, *hostName;
  774.     int length;
  775.     HKEY rootKey;
  776.     DWORD result;
  777.  
  778.     keyName = Tcl_GetStringFromObj(keyNameObj, &length);
  779.     buffer = ckalloc(length + 1);
  780.     strcpy(buffer, keyName);
  781.  
  782.     result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
  783.     if (result == TCL_OK) {
  784.     result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr);
  785.     if (result != ERROR_SUCCESS) {
  786.         Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
  787.         Tcl_AppendToObj(resultPtr, "unable to open key: ", -1);
  788.         AppendSystemError(interp, result);
  789.         result = TCL_ERROR;
  790.     } else {
  791.         result = TCL_OK;
  792.     }
  793.     }
  794.  
  795.     ckfree(buffer);
  796.     return result;
  797. }
  798.  
  799. /*
  800.  *----------------------------------------------------------------------
  801.  *
  802.  * OpenSubKey --
  803.  *
  804.  *    This function opens a given subkey of a root key on the
  805.  *    specified host.
  806.  *
  807.  * Results:
  808.  *    Returns the opened key in the keyPtr and a Windows error code
  809.  *    as the return value.
  810.  *
  811.  * Side effects:
  812.  *    None.
  813.  *
  814.  *----------------------------------------------------------------------
  815.  */
  816.  
  817. static DWORD
  818. OpenSubKey(
  819.     char *hostName,        /* Host to access, or NULL for local. */
  820.     HKEY rootKey,        /* Root registry key. */
  821.     char *keyName,        /* Subkey name. */
  822.     REGSAM mode,        /* Access mode. */
  823.     int flags,            /* 0 or REG_CREATE. */
  824.     HKEY *keyPtr)        /* Returned HKEY. */
  825. {
  826.     DWORD result;
  827.  
  828.     /*
  829.      * Attempt to open the root key on a remote host if necessary.
  830.      */
  831.  
  832.     if (hostName) {
  833.     result = RegConnectRegistry(hostName, rootKey, &rootKey);
  834.     if (result != ERROR_SUCCESS) {
  835.         return result;
  836.     }
  837.     }
  838.  
  839.     /*
  840.      * Now open the specified key with the requested permissions.  Note
  841.      * that this key must be closed by the caller.
  842.      */
  843.  
  844.     if (flags & REG_CREATE) {
  845.     DWORD create;
  846.     result = RegCreateKeyEx(rootKey, keyName, 0, "",
  847.         REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
  848.     } else {
  849.     result = RegOpenKeyEx(rootKey, keyName, 0, mode, keyPtr);
  850.     }
  851.  
  852.     /*
  853.      * Be sure to close the root key since we are done with it now.
  854.      */
  855.  
  856.     if (hostName) {
  857.     RegCloseKey(rootKey);
  858.     }
  859.     return result; 
  860. }
  861.  
  862. /*
  863.  *----------------------------------------------------------------------
  864.  *
  865.  * ParseKeyName --
  866.  *
  867.  *    This function parses a key name into the host, root, and subkey
  868.  *    parts. 
  869.  *
  870.  * Results:
  871.  *    The pointers to the start of the host and subkey names are
  872.  *    returned in the hostNamePtr and keyNamePtr variables.  The
  873.  *    specified root HKEY is returned in rootKeyPtr.  Returns
  874.  *    a standard Tcl result.
  875.  *
  876.  *
  877.  * Side effects:
  878.  *    Modifies the name string by inserting nulls.
  879.  *
  880.  *----------------------------------------------------------------------
  881.  */
  882.  
  883. static int
  884. ParseKeyName(
  885.     Tcl_Interp *interp,        /* Current interpreter. */
  886.     char *name,
  887.     char **hostNamePtr,
  888.     HKEY *rootKeyPtr,
  889.     char **keyNamePtr)
  890. {
  891.     char *rootName;
  892.     int result, index;
  893.     Tcl_Obj *rootObj, *resultPtr = Tcl_GetObjResult(interp);
  894.  
  895.     /*
  896.      * Split the key into host and root portions.
  897.      */
  898.  
  899.     *hostNamePtr = *keyNamePtr = rootName = NULL;
  900.     if (name[0] == '\\') {
  901.     if (name[1] == '\\') {
  902.         *hostNamePtr = name;
  903.         for (rootName = name+2; *rootName != '\0'; rootName++) {
  904.         if (*rootName == '\\') {
  905.             *rootName++ = '\0';
  906.             break;
  907.         }
  908.         }
  909.     }
  910.     } else {
  911.     rootName = name;
  912.     }
  913.     if (!rootName) {
  914.     Tcl_AppendStringsToObj(resultPtr, "bad key \"", name,
  915.         "\": must start with a valid root", NULL);
  916.     return TCL_ERROR;
  917.     }
  918.  
  919.     /*
  920.      * Split the root into root and subkey portions.
  921.      */
  922.  
  923.     for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) {
  924.     if (**keyNamePtr == '\\') {
  925.         **keyNamePtr = '\0';
  926.         (*keyNamePtr)++;
  927.         break;
  928.     }
  929.     }
  930.  
  931.     /*
  932.      * Look for a matching root name.
  933.      */
  934.  
  935.     rootObj = Tcl_NewStringObj(rootName, -1);
  936.     result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name",
  937.         TCL_EXACT, &index);
  938.     Tcl_DecrRefCount(rootObj);
  939.     if (result != TCL_OK) {
  940.     return TCL_ERROR;
  941.     }
  942.     *rootKeyPtr = rootKeys[index];
  943.     return TCL_OK;
  944. }
  945.  
  946. /*
  947.  *----------------------------------------------------------------------
  948.  *
  949.  * RecursiveDeleteKey --
  950.  *
  951.  *    This function recursively deletes all the keys below a starting
  952.  *    key.  Although Windows 95 does this automatically, we still need
  953.  *    to do this for Windows NT.
  954.  *
  955.  * Results:
  956.  *    Returns a Windows error code.
  957.  *
  958.  * Side effects:
  959.  *    Deletes all of the keys and values below the given key.
  960.  *
  961.  *----------------------------------------------------------------------
  962.  */
  963.  
  964. static DWORD
  965. RecursiveDeleteKey(
  966.     HKEY startKey,        /* Parent of key to be deleted. */
  967.     char *keyName)        /* Name of key to be deleted. */
  968. {
  969.     DWORD result, subKeyLength;
  970.     Tcl_DString subkey;
  971.     HKEY hKey;
  972.  
  973.     /*
  974.      * Do not allow NULL or empty key name.
  975.      */
  976.  
  977.     if (!keyName || lstrlen(keyName) == '\0') {
  978.     return ERROR_BADKEY;
  979.     }
  980.  
  981.     result = RegOpenKeyEx(startKey, keyName, 0,
  982.         KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);
  983.     if (result != ERROR_SUCCESS) {
  984.     return result;
  985.     }
  986.     result = RegQueryInfoKey(hKey, NULL, NULL, NULL, NULL, &subKeyLength,
  987.         NULL, NULL, NULL, NULL, NULL, NULL);
  988.     subKeyLength++;
  989.     if (result != ERROR_SUCCESS) {
  990.     return result;
  991.     }
  992.  
  993.     Tcl_DStringInit(&subkey);
  994.     Tcl_DStringSetLength(&subkey, subKeyLength);
  995.  
  996.     while (result == ERROR_SUCCESS) {
  997.     /*
  998.      * Always get index 0 because key deletion changes ordering.
  999.      */
  1000.  
  1001.     subKeyLength = Tcl_DStringLength(&subkey);
  1002.     result=RegEnumKeyEx(hKey, 0, Tcl_DStringValue(&subkey), &subKeyLength,
  1003.         NULL, NULL, NULL, NULL);
  1004.     if (result == ERROR_NO_MORE_ITEMS) {
  1005.         result = RegDeleteKey(startKey, keyName);
  1006.         break;
  1007.     } else if (result == ERROR_SUCCESS) {
  1008.         result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));
  1009.     }
  1010.     }
  1011.     Tcl_DStringFree(&subkey);
  1012.     RegCloseKey(hKey);
  1013.     return result;
  1014. }
  1015.  
  1016. /*
  1017.  *----------------------------------------------------------------------
  1018.  *
  1019.  * SetValue --
  1020.  *
  1021.  *    This function sets the contents of a registry value.  If
  1022.  *    the key or value does not exist, it will be created.  If it
  1023.  *    does exist, then the data and type will be replaced.
  1024.  *
  1025.  * Results:
  1026.  *    Returns a normal Tcl result.
  1027.  *
  1028.  * Side effects:
  1029.  *    May create new keys or values.
  1030.  *
  1031.  *----------------------------------------------------------------------
  1032.  */
  1033.  
  1034. static int
  1035. SetValue(
  1036.     Tcl_Interp *interp,        /* Current interpreter. */
  1037.     Tcl_Obj *keyNameObj,    /* Name of key. */
  1038.     Tcl_Obj *valueNameObj,    /* Name of value to set. */
  1039.     Tcl_Obj *dataObj,        /* Data to be written. */
  1040.     Tcl_Obj *typeObj)        /* Type of data to be written. */
  1041. {
  1042.     DWORD type, result;
  1043.     HKEY key;
  1044.     int length;
  1045.     char *valueName;
  1046.     Tcl_Obj *resultPtr;
  1047.  
  1048.     if (typeObj == NULL) {
  1049.     type = REG_SZ;
  1050.     } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type",
  1051.         0, (int *) &type) != TCL_OK) {
  1052.     if (Tcl_GetIntFromObj(NULL, typeObj, (int*) &type) != TCL_OK) {
  1053.         return TCL_ERROR;
  1054.     }
  1055.     Tcl_ResetResult(interp);
  1056.     }
  1057.     if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
  1058.     return TCL_ERROR;
  1059.     }
  1060.  
  1061.     valueName = Tcl_GetStringFromObj(valueNameObj, &length);
  1062.     resultPtr = Tcl_GetObjResult(interp);
  1063.  
  1064.     if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
  1065.     DWORD value;
  1066.     if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) {
  1067.         RegCloseKey(key);
  1068.         return TCL_ERROR;
  1069.     }
  1070.  
  1071.     value = ConvertDWORD(type, value);
  1072.     result = RegSetValueEx(key, valueName, 0, type, (BYTE*) &value,
  1073.         sizeof(DWORD));
  1074.     } else if (type == REG_MULTI_SZ) {
  1075.     Tcl_DString data;
  1076.     int objc, i;
  1077.     Tcl_Obj **objv;
  1078.     char *element;
  1079.  
  1080.     if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
  1081.         RegCloseKey(key);
  1082.         return TCL_ERROR;
  1083.     }
  1084.  
  1085.     /*
  1086.      * Append the elements as null terminated strings.  Note that
  1087.      * we must not assume the length of the string in case there are
  1088.      * embedded nulls, which aren't allowed in REG_MULTI_SZ values.
  1089.      */
  1090.  
  1091.     Tcl_DStringInit(&data);
  1092.     for (i = 0; i < objc; i++) {
  1093.         element = Tcl_GetStringFromObj(objv[i], NULL);
  1094.         Tcl_DStringAppend(&data, element, -1);
  1095.         Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
  1096.     }
  1097.     result = RegSetValueEx(key, valueName, 0, type,
  1098.         (LPBYTE) Tcl_DStringValue(&data),
  1099.         (DWORD) (Tcl_DStringLength(&data)+1));
  1100.     Tcl_DStringFree(&data);
  1101.     } else {
  1102.     char *data = Tcl_GetStringFromObj(dataObj, &length);
  1103.  
  1104.     /*
  1105.      * Include the null in the length if we are storing a null terminated
  1106.      * string.  Note that we also need to call strlen to find the first
  1107.      * null so we don't pass bad data to the registry.
  1108.      */
  1109.  
  1110.     if (type == REG_SZ || type == REG_EXPAND_SZ) {
  1111.         length = strlen(data) + 1;
  1112.     }
  1113.  
  1114.     result = RegSetValueEx(key, valueName, 0, type, (LPBYTE)data, length);
  1115.     }
  1116.     RegCloseKey(key);
  1117.     if (result != ERROR_SUCCESS) {
  1118.     Tcl_AppendToObj(resultPtr, "unable to set value: ", -1);
  1119.     AppendSystemError(interp, result);
  1120.     return TCL_ERROR;
  1121.     }
  1122.     return TCL_OK;
  1123. }
  1124.  
  1125. /*
  1126.  *----------------------------------------------------------------------
  1127.  *
  1128.  * AppendSystemError --
  1129.  *
  1130.  *    This routine formats a Windows system error message and places
  1131.  *    it into the interpreter result.
  1132.  *
  1133.  * Results:
  1134.  *    None.
  1135.  *
  1136.  * Side effects:
  1137.  *    None.
  1138.  *
  1139.  *----------------------------------------------------------------------
  1140.  */
  1141.  
  1142. static void
  1143. AppendSystemError(
  1144.     Tcl_Interp *interp,        /* Current interpreter. */
  1145.     DWORD error)        /* Result code from error. */
  1146. {
  1147.     int length;
  1148.     char *msgbuf, id[10];
  1149.     Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
  1150.  
  1151.     sprintf(id, "%d", error);
  1152.     length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
  1153.         | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
  1154.         MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR)&msgbuf,
  1155.         0, NULL);
  1156.     if (length == 0) {
  1157.     if (error == ERROR_CALL_NOT_IMPLEMENTED) {
  1158.         msgbuf = "function not supported under Win32s";
  1159.     } else {
  1160.         msgbuf = id;
  1161.     }
  1162.     } else {
  1163.     /*
  1164.      * Trim the trailing CR/LF from the system message.
  1165.      */
  1166.     if (msgbuf[length-1] == '\n') {
  1167.         msgbuf[--length] = 0;
  1168.     }
  1169.     if (msgbuf[length-1] == '\r') {
  1170.         msgbuf[--length] = 0;
  1171.     }
  1172.     }
  1173.     Tcl_SetErrorCode(interp, "WINDOWS", id, msgbuf, (char *) NULL);
  1174.     Tcl_AppendToObj(resultPtr, msgbuf, -1);
  1175.  
  1176.     if (length != 0) {
  1177.     LocalFree(msgbuf);
  1178.     }
  1179. }
  1180.  
  1181. /*
  1182.  *----------------------------------------------------------------------
  1183.  *
  1184.  * ConvertDWORD --
  1185.  *
  1186.  *    This function determines whether a DWORD needs to be byte
  1187.  *    swapped, and returns the appropriately swapped value.
  1188.  *
  1189.  * Results:
  1190.  *    Returns a converted DWORD.
  1191.  *
  1192.  * Side effects:
  1193.  *    None.
  1194.  *
  1195.  *----------------------------------------------------------------------
  1196.  */
  1197.  
  1198. static DWORD
  1199. ConvertDWORD(
  1200.     DWORD type,            /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */
  1201.     DWORD value)        /* The value to be converted. */
  1202. {
  1203.     DWORD order = 1;
  1204.     DWORD localType;
  1205.  
  1206.     /*
  1207.      * Check to see if the low bit is in the first byte.
  1208.      */
  1209.  
  1210.     localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
  1211.     return (type != localType) ? SWAPLONG(value) : value;
  1212. }
  1213.